Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/comm/simpcomm.frm

Visual Basic Form | 1995-05-08 | 17.3 KB | 403 lines

VERSION 2.00
Begin Form Form1
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Form1"
   ClientHeight    =   4230
   ClientLeft      =   1080
   ClientTop       =   1815
   ClientWidth     =   7365
   Height          =   4635
   Icon            =   SIMPCOMM.FRX:0000
   Left            =   1020
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4230
   ScaleWidth      =   7365
   Top             =   1470
   Width           =   7485
   WindowState     =   1  'Minimized
   Begin CommandButton Command_Send
      Caption         =   "Send Text"
      Height          =   1215
      Left            =   1080
      TabIndex        =   0
      Top             =   2160
      Width           =   1695
   End
   Begin Timer Timer_ClearStatusMessage
      Left            =   120
      Top             =   600
   End
   Begin TextBox Text_Display
      BackColor       =   &H00C0C0C0&
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "Courier"
      FontSize        =   9.75
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   1580
      Left            =   1080
      MultiLine       =   -1  'True
      TabIndex        =   1
      Top             =   160
      Width           =   5175
   End
   Begin Timer Timer_CheckReceiveBuffer
      Left            =   120
      Top             =   120
   End
   Begin Label Label_StatusBar
      BackColor       =   &H00C0C0C0&
      ForeColor       =   &H00000000&
      Height          =   620
      Left            =   360
      TabIndex        =   2
      Top             =   3520
      Width           =   6375
   End
'*************************************************
'* GENERAL DECLARATIONS section of Form1
'*************************************************
DefInt A-Z
Dim DCB As CommStateDCB     'COM Device Control Block (DCB) record structure variable
                'This is a parameter needed by the Windows SetCommState API
                'function.
                'Refer to Form_Load event procedure for an example of
                'how initialize the COM DCB
Dim CommStat As COMSTAT     'COM status variable.
                'This is a parameter needed by the Windows GetCommError API
                'function
Dim ComID                   'Identifies the COM port that was opened.
                'Used by or returned by the Windows API functions
                'OpenComm, GetCommState, SetCommEventMask, GetCommEventMask,
                'ReadComm, WriteComm, FlushComm, CloseComm
'**************************************************************
'* This event procedure demonstrates how to call the Windows
'* API function WriteComm to send data out the COM port.
'* Click event procedure for the command button
'* (CtlName: Command_Send) that causes the contents
'* of the text box (CtlName: Text_Display) to be sent
'* out the COM port.
'* Status information is displayed within caption of a
'* label (CtlName: Label_StatusBar).
'***************************************************************
Sub Command_Send_Click ()
    'Get the data to be sent from the text box.  Note: All
    'of the text contained in the text box is sent.
    buffer$ = Text_Display.text
    'Send the contents of the output buffer out the COM port
    r = WriteComm(ComID, buffer$, Len(buffer$))
    'Display any communications errors that might have occurred
    'when attempting to write to the COM port
    Call ProcessCommError
End Sub
'****************************************************************************
'* Form_Load event procedure for Form1
'* This is starting point of the program.
'* Create the following controls with the
'* following CtlNames on Form1:
'* Control
'* (Default Name)     CtlName                  Notes
'* --------------     -------                  ---------------------------------
'*   Text1            Text_Display             Set the MultiLine property to True
'*   Command1         Command_Send             Set caption property to "Send Text"
'*   Timer1           Timer_CheckReceiveBuffer
'*   Timer2           Timer_ClearStatusMessage
'*   Label1           Label_StatusBar
'* This event procedure demonstrates how to call the Windows API functions,
'* OpenComm and SetCommState to open the COM port.  In this example, the
'* COM port is opened as the following equivalent QuickBASIC OPEN COM string:
'*     "COM1:1200,N,8,1,DS0,CS0,CD0,RS,TB2048,RB2048"
'******************************************************************************
Sub Form_Load ()
    'Move the COM status window to the bottom of the form
    Label_StatusBar.Move 0, Label_StatusBar.Top, Form1.ScaleWidth
    Form1.Show
    'Show a status message indicating that the COM port is being opened
    Call ShowStatus("Opening COM1 ...")
    Do
    'Open COM1 with a 2K input and output buffer
    ComID = OpenComm("COM2", 2048, 2048)
    If ComID < 0 Then
        Call ShowOpenCommError(ComID)
        If ComID = IE_OPEN Then
        m$ = "COM device already opened" + Chr$(13) + Chr$(13)
        m$ = m$ + "Do you wish to use it anyway"
        Response = MsgBox(m$, 36, "Communications Error")
        'Close the com port if the user selected Yes from the message box
        If Response = 6 Then
            'Close the COM port if the user decided to use it anyway
            r = CloseComm(Asc(DCB.Id))
        Else

            'Display a message and terminate the program
            'if the user decided not to use the COM port
            'that is currently open
            m$ = "Terminating application"
            MsgBox m$, 16, "Communications Abort"
            End
        End If
        Else
        'Display a critical error message and terminate the program
        m$ = "Error occurred attempting to open the COM port."
        m$ = m$ + "  Check connection, settings and rerun the program"
        MsgBox m$, 16, "Communications Error"
        End
        End If
    Else
        'Set line settings for the COM port as 1200:N,8,1,CD0,CS0,DS0,RS,TB2048,RB2048
        '
        'The following parameter settings represent the default settings set by calling
        'BuildCommDCB in the Form_Load event procedure.
        '
        'Set parameters as 1200: N,8,1
        DCB.Id = Chr$(ComID)
        DCB.BaudRate = 1200             'Other possible values include 300, 2400, 4800, 9600, 19200
        DCB.ByteSize = Chr$(8)          'Other possible values include 4,5,6,7
        DCB.Parity = Chr$(NOPARITY)     'Other possible values include EVENPARITY, MARKPARITY, ODDPARITY, SPACEPARITY
        DCB.StopBits = Chr$(ONESTOPBIT) 'Other possible values include ONE5STOPBITS, TWOSTOPBITS

        'Set timeout period for CD, CS and DS handshake lines respectively.  Values
        'represent milliseconds.  A value of zero represents an infinite wait effectively
        'disabling handshaking on that line.  Possible values can range from 0 to 65,535
        'for an unsiged integer or -32,768 to 32,767 for signed integers.
        '
        DCB.RlsTimeOut = 0         'Carrier detect or receive-line-signal-detect (CD or RLSD) line (CD0)
        DCB.CtsTimeOut = 0         'Clear-to-send (CTS) line (CS0)
        DCB.DsrTimeOut = 0         'Data-set-ready (DSR) line (DS0)

        'The following bit flags are combined in the ModeControl field below.  Because
        'the following are bit fields they cannot be represented as a field of a Type ... End Type
        'structure

        'DCB.fBinary = 1            Specify binary mode.  Setting this to zero causes an
        '                           EOF character (Chr$(26)) to signal the end of data.
        'DCB.fRtsDisabled = 1       Disable request-to-send line (RS).  A zero value enables
        '                           the request-to-send line
        'DCB.fParity = 0            Disable parity checking.  A value of 1 enables parity checking
        'DCB.fOutCtsFlow = 0        Disable checking of clear-to-send line for output flow control
        'DCB.fOutxDsrFlow = 0       Disable checking of data-set-ready (DSR) line for output flow control
        'DCB.fDummy = 0 + 0         Two bit reserved field
        'DCB.fDtrDisabled = 1       Disable the data-set-ready line (DTR).  A value of 1 enables DTR.
        '
        'DCB.fOutX = 0              Disable XON/XOFF during transmission.
        '                           A value of 1 enables XON/XOFF.
        'DCB.fInX = 0               Disable XON/XOFF during reception.
        '                           A value of 1 enables XON/XOFF
        'DCB.fPeChar = 0            Disable the replace of parity error characters with the character
        '                           contained in the PeChar field.  A value of 1 enables replacement
        '                           of parity error characters with the character contained in the
        '                           PeChar field.
        '
        'DCB.fNull = 0              Received null characters are not to be discarded.  A value of 1
        '                           specifies that null characters received will be discarded.
        '
        'DCB.fChEvt = 0             Reception of the character contained in the EvtChar field does
        '                           not signify an event.  A value of 1 indicates that the
        '                           reception of a character identical to the character contained
        '                           in the EvtChar field signifies and event.
        '
        'DCB.fDtrFlow = 0           The DTR line is not used for receive flow control.  A value of 1
        '                           indicates that the DTR line is used for receive flow control.
        'DCB.fRtsFlow = 0           The RTS line is not used for receive flow control.  A value of 1
        '                           indicates that the DTR line is used for receive flow control.
        'DCB.fDummy = 0             Reserved
        '
        '1100 0001 0000 0000        Binary representation
        '                           of the above bit settings
        '
        '  C    1    0    0         Hex representation of the above
        '                           bit settings
        DCB.ModeControl = &H83     'Based on the bit settings above
        DCB.XonChar = Chr$(0)
        DCB.XoffChar = Chr$(0)
        DCB.XonLim = 0
        DCB.XoffLim = 0
        DCB.peChar = Chr$(0)
        DCB.EofChar = Chr$(26)
        DCB.EvtChar = Chr$(0)
        Call ShowStatus("Setting COM State ... ")
        'Set the COM port with the settings as indicated above
        r = SetCommState(DCB)

        If r < 0 Then
        m$ = "Error occurred during initialization of COM settings."
        m$ = m$ + "  Check connection, settings and rerun this program"
        MsgBox m$, 16, "Communications Error"
        Unload Form1
        Else
        'Start the timer to continuously check the receive buffer
        'Start the timer only if no errors occurred
        Timer_CheckReceiveBuffer.Interval = 1
        Timer_CheckReceiveBuffer.Enabled = True
        'Set the focus on the text box
        Text_Display.SetFocus
        End If
    End If
    Loop While ComID < 0
End Sub
'***************************************************************************
'* This event procedure demonstrates how to call the Windows API functions
'* FlushComm and CloseComm to close the COM port.
'* Close the COM port and end the program.
'***************************************************************************
Sub Form_Unload (Cancel As Integer)
    'Flush the COM transmit and receive buffers.  Note: the return value represents
    'the success of the FlushComm function call.  Zero = success; Negative = non-success
    'The return value is ignored in this example.
    r = FlushComm(ComID, 0)   'Flush all characters in the transmit buffer
    r = FlushComm(ComID, 1)   'Flush all characters in the receive buffer
    r = CloseComm(ComID)
    If r < 0 Then
    MsgBox "Error Closing the COM Port", 48, "Communications Error"
    End If
    End
End Sub
'**********************************************************************
'* Display message boxes for any communications
'* errors that may occurred when attempting to read from or write to
'* the COM port.  Since more than 1 error can occur when attempting
'* to read from or write to the COM port, several messages boxes may
'* be displayed.
'* IMPORTANT: If an error occurs during communications, Windows locks
'*            the COM port.  The COM port can only be unlocked by
'*            calling the Windows API function GetCommError.
'**********************************************************************
Sub ProcessCommError ()
    CR$ = Chr$(13)      'Character representing a carriage-return
    'Find out if an error occurs.  Calling GetCommError clears
    'the error and causes Windows to unlock the COM port.
    e = GetCommError(ComID, CommStat)
    If e <> 0 Then
    If (e And CE_BREAK) = CE_BREAK Then
        message$ = "Break condition detected"
        GoSub ShowMessage
    End If
    If (e And CE_CTSTO) = CE_CTSTO Then
        message$ = "Clear-to-send (CTS) timeout"
        GoSub ShowMessage
    End If
    If (e And CE_DSRTO) = CE_DSRTO Then
        message$ = "Data-set-ready (DSR) timeout"
        GoSub ShowMessage
    End If
    If (e And CE_DNS) = CE_DNS Then
        message$ = "Parallel device is not selected"
        GoSub ShowMessage
    End If
    If (e And CE_FRAME) = CE_FRAME Then
        message$ = "Framing error detected"
        GoSub ShowMessage
    End If
    If (e And CE_IOE) = CE_IOE Then
        message$ = "Device I/O error occurred" + CR$
        message$ = message$ + "attempting to communicate with parallel device"
        GoSub ShowMessage
    End If
    If (e And CE_MODE) = CE_MODE Then
        message$ = "Requested mode is not supported"
        GoSub ShowMessage
    End If
    If (e And CE_OOP) = CE_OOP Then
        message$ = "Out of paper on parallel device"
        GoSub ShowMessage
    End If
    If (e And CE_OVERRUN) = CE_OVERRUN Then
        message$ = "Overrun error detected"
        GoSub ShowMessage
    End If
    If (e And CE_PTO) = CE_PTO Then
        message$ = "Timeout attempting to communicate with" + CR$
        message$ = message$ + "parallel device"
        GoSub ShowMessage
    End If
    If (e And CE_RLSDTO) = CE_RLSDTO Then
        message$ = "Receive-line-signal-detect timeout"
        GoSub ShowMessage
    End If
    If (e And CE_RXOVER) = CE_RXOVER Then
        message$ = "Receive buffer overflow"
        GoSub ShowMessage
    End If
    If (e And CE_RXPARITY) = CE_RXPARITY Then
        message$ = "Parity error detected"
        GoSub ShowMessage
    End If
    If (e And CE_TXFULL) = CE_TXFULL Then
        message$ = "Transmit buffer full"
        GoSub ShowMessage
    End If
    End If
Exit Sub
ShowMessage:
    MsgBox message$, 48, "Communications Error"
    Return
End Sub
'****************************************************************
'* Displays a message box for any communications error that
'* may have occurred while attempting to open the COM port.
'****************************************************************
Sub ShowOpenCommError (ErrorCode)
    Select Case ErrorCode
    Case IE_BADID
        message$ = "Invalid or unsupported ID"
    Case IE_BAUDRATE
        message$ = "Unsupported baud rate"
    Case IE_BYTESIZE
        message$ = "Invalid byte size"
    Case IE_DEFAULT
        message$ = "Error in default parameters"
    Case IE_HARDWARE
        message$ = "Hardware not present"
    Case IE_MEMORY
        message$ = "Unable to allocate queues"
    Case IE_NOPEN
        message$ = "Device not open"
    Case IE_OPEN
        message$ = "Device already opened"
    End Select
    MsgBox message$, 48, "Communications Error"
End Sub
'**********************************************************
'* Show a COM status message at the bottom of the form
'**********************************************************
Sub ShowStatus (StatusMsg$)
    'Show the message
    Label_StatusBar.Caption = StatusMsg$
    Label_StatusBar.Refresh
    'Set the timer interval to clear the message
    Timer_ClearStatusMessage.Interval = 3000
    Timer_ClearStatusMessage.Enabled = True
End Sub
'************************************************************
'* This event procedure demonstrates how to call the Windows
'* API function ReadComm to read information from the COM
'* port
'************************************************************
Sub Timer_CheckReceiveBuffer_Timer ()
    'Read in up to 2K of data from the COM receive buffer
    buffer$ = Space$(2048)
    'Read characters waiting in the receive buffer.
    r = ReadComm(ComID, buffer$, Len(buffer$))
    'If characters were returned in the buffer, display them
    'in the text box.  The absolute value of the return value
    'for ReadComm indicates how many characters were read from the COM.
    If r <> 0 Then
    Text_Display.SelStart = Len(Text_Display.text)
    Text_Display.SelText = Left$(buffer$, Abs(r))
    End If
    'Display any errors that may have occurred reading from the COM
    Call ProcessCommError
End Sub
'**********************************************************
'* Clear the COM status window and disable the timer
'**********************************************************
Sub Timer_ClearStatusMessage_Timer ()
    Label_StatusBar.Caption = ""
    Timer_ClearStatusMessage.Enabled = False
End Sub